;;;-*-LISP-*-
;;;; SCHEME sprint package.

(defmacro stringp (object)
  `(and (atom ,object) (< (flatc ,object) (flatsize ,object))))

;;; Display functions:

(defun into fexpr (all-three) ;moves a property from one to another
  (putprop (car all-three)
	   (car (remprop (cadr all-three)
			 (caddr all-three)))
	   (caddr all-three)))

(into oprin1 prin1 lsubr)
(defun prin1 (obj)
  (cond (*display-flag*
	 (princ obj))
	(t (oprin1 obj))))

(into oflatsize flatsize subr)
(defun flatsize (obj)
  (cond (*display-flag*
	 (flatc obj))
	(t (oflatsize obj))))

(declare (special *formals* *bodies* *terse?* *noprint* nn
		  linel *rset nouuo *display-flag* *last-indented*))

(setq *terse?* t)
(setq *bodies* nil)
(setq *formals* nil)
(setq *display-flag* nil)
(setq *last-indented* 1)

(include "<scheme.development>Lgrind.lsp")

(into oturpri turpri subr)
(defun turpri ()
  (setq *last-indented* nn)
  (oturpri))

(setq grind-standard-quote nil)

;;; User interface

(defun jinx-print (l)
  (let ((*bodies* nil)
	(*formals* nil)
	(linel (grlinel))
	(*rset grind*rset)
	(hunksprin1 'scheme-hunksprin1)
	(nouuo grind*rset)
	(nn (grlinel))
	(*last-indented* (grlinel)))
    (terpri)
    (sprint l linel 0.)
    (terpri)
    *noprint*))

(defun jinx-pp (object)
  (jinx-print (list '*no-terse* object)))

(defun display objects
  (jinx-print
   (list '*print-sequence*
	 (mapcar #'(lambda (x)
		     (if (stringp x)
			 (list '*display* x)
			 x))
		 (listify objects)))))

(defun display-messages objects
  (jinx-print
   (list '*print-sequence* (reverse (disp-1 (listify objects) nil)))))

(defun disp-1 (objects so-far)
  (if (null objects) so-far
      (disp-1 (cddr objects)
	      (cons (if (null (cdr objects))
			(list '*display* (car objects))
			(list '*print-sequence*
			      (list (list '*display* (car objects))
				    (cadr objects))))
		    so-far))))

(defun highlight (pointer object)
  (jinx-pp (subst `(*highlight* ,pointer) pointer object)))

;;; Unsyntaxing of bodies will occur only once.

(defmacro my-sch-procedure-body (proc)
  `(let ((found (assq ,proc *bodies*)))
     (cond ((null found)
	    (cdar (setq *bodies*
			(cons
			 (cons ,proc (sch-procedure-body ,proc)) *bodies*))))
	   (t (cdr found)))))


(defmacro my-sch-procedure-formals (proc)
  `(let ((found (assq ,proc *formals*)))
    (cond ((null found)
	   (cdar
	    (setq *formals*
		  (cons
		   (cons ,proc
			 (formals (sch-procedure-formals ,proc)
				  (sch-procedure-name ,proc))) *formals*))))
	  (t (cdr found)))))
  
(defun formals (args name)
  (if (null name) args
       (cons name args)))


;;;; Scheme special-form grinding
;;; Defines, lambdas and lets

(defun define-form ()  ;Two cases of define.
  (cond ((atom (cadr l))
	 (setq-form))
	(t (sch-lambda-form))))

(grindfn define define-form)

(defun sch-lambda-form () ;l n m free
  (princ (car l))
  (print-body l (cadr l) (cddr l) n m '/))
  (setq l nil))  ;sprint1 tests on return for nil l.
  
(grindfn (lambda let) sch-lambda-form) ;lambda and let like define.

;;;; Quoted grinding: don't print quote-mark if string

(defun (quote grindmacro) ()
  (cond ((stringp (cadr l))
	 (prin1 (cadr l)))
	(t (princ '/')
	   (sprint1 (cadr l) (grchrct) m)))
  t) ;sprint1 tests for value returned and if nil, proceeds as if list.


(defun (quote grindflatsize) (object)
  (cond ((stringp (cadr object))
	 (flatsize (cadr object)))
	(t (1+ (gflatsize (cadr object))))))

;;; Highlighted expressions

(defun (*highlight* grindmacro) ()
  (let ((q (grchrct)))
    (let ((n (cond ((and (> (- linel q) 3) (= q *last-indented*))
		    (do ((i 1 (1+ i))) ((> i 4) q) (princ (ascii 8.))))
		   ((= q *last-indented*)
		    (- q 4))
		   (t (indent-to (setq q (min (+ q 4) linel)))
		      (- q 4)))))
      (princ "*-> ")
      (sprint1 (cadr l) n (+ 4 m))
      (princ " <-*"))
    t))

(defun (*highlight* grindflatsize) (object)
  (+ 8. (gflatsize (cadr object))))

;;; Displayed expressions

(defun (*display* grindmacro) ()
  (let ((*display-flag* t))
    (sprint1 (cadr l) n m)
    t))

(defun (*display* grindflatsize) (object)
  (let ((*display-flag* t))
    (gflatsize (cadr object))))

(defun (*print-sequence* grindmacro) ()
  (print-sequence (cadr l) (cadr l) n m 0)
  t)

(defun (*print-sequence* grindflatsize) (object)
  (body-flatsize (cadr object)))

;;; Pretty-printed expressions

(defun (*no-terse* grindmacro) ()
  (let ((*terse?* nil))
    (sprint1 (cadr l) n m)
    t))

(defun (*no-terse* grindflatsize) (object)
  (let ((*terse?* nil))
    (gflatsize (cadr object))))


;;;; Data driven Scheme objects grinding.

(defun scheme-hunksprin1 (l n m)
  (funcall (get (primitive-type l) 'sch-pretty-print) l n m))

(defun (scheme-hunksprin1 hunkgflatsize) (x)
  (funcall (get (primitive-type x) 'sch-flatsize) x))

;;; Formatting of primitive-procedures.

(defun (primitive-procedure sch-pretty-print) (object left pars)
  (princ "[PRIMITIVE ")
  (princ (sch-procedure-name object))
  (princ "]"))

(defun (primitive-procedure sch-flatsize) (x)
  (+ 12. (flatc (sch-procedure-name x))))

;;; Formatting of compound-procedures.

(defun (compound-procedure sch-pretty-print) (object left pars)
  (let ((nam (sch-procedure-name object)))
    (cond ((null nam)
	   (princ "[LAMBDA-PROCEDURE "))
	  (t (princ "[PROCEDURE ")))
    (cond (*terse?*
	   (cond ((null nam) (princ (maknum object)))
		 (t (princ nam)))
	   (princ "]"))
	  (t (print-body object
			 (my-sch-procedure-formals object)
			 (my-sch-procedure-body object) left pars '/])))))

(defun (compound-procedure sch-flatsize) (proc)
  (let ((nam (sch-procedure-name proc))
	(tot 11.))
    (cond (*terse?*
	   (if (null nam)
	       (+ 7. tot (1+ (flatc (maknum proc))))
	       (+ 1 (flatc nam) tot)))
	  (t (+ tot
		(proc-flatsize (my-sch-procedure-formals proc)
			       (my-sch-procedure-body proc)))))))

(defun print-body (object formals body left pars closing-char)
  (princ " ")
  (sprint1 formals (grchrct) 1)
  (princ " ")
  (print-sequence object body left pars 3.)
  (princ closing-char)
  t)

(defun print-sequence (object body left pars indent)
  (cond ((< (gflatsize object) (- left pars))
	 (map #'(lambda (x) (sprint1 (car x) (grchrct) 1)
			(cond ((cdr x) (princ " "))))
	      body))
	(t (map
	    #'(lambda (x)
		(cond ((cdr x)
		       (sprint1 (car x) (- left indent) 0))
		      (t (sprint1 (car x)
				  (- left indent) (+ pars 1)))))
	    body)))
  t)

(defun proc-flatsize (formals body) ;doesn't include pars.
  (+ 2. (gflatsize formals) 
     (body-flatsize body)))

(defun body-flatsize (body)
  (+ -1. (length body)
     (apply (function +)
	    (mapcar (function gflatsize) body))))))

;;; Formatting of arrays

(defun (array sch-pretty-print) (object left pars)
  (princ "[ARRAY ")
  (princ (maknum object))
  (if *terse?*
      (princ "]")
      (sprint1 (scharraydims object)
	       (cond ((< (gflatsize object) (- left pars))
		      (1+ (grchrct)))
		     (t (- left 3)))
	       (+ pars 1))
      (princ "]")))

(defun (array sch-flatsize) (arr)
  (+ 8. (flatc (maknum arr))
     (if *terse?* 0 (1+ (gflatsize (scharraydims arr))))))

;;; Formatting of environments

(defun (environment sch-pretty-print) (object left pars)
  (princ "[ENVIRONMENT ")
  (princ (maknum object))
  (princ "]"))

(defun (environment sch-flatsize) (env)
  (+ 14. (flatc (maknum env))))

;;; Formatting of unidentified objects

(defun (unidentified-object sch-pretty-print) (object left pars)
  (princ "[RANDOM←OBJECT ")
  (princ (maknum object))
  (princ "]"))

(defun (unidentified-object sch-flatsize) (obj)
  (+ 16. (flatc (maknum obj))))